home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
progjour
/
1991
/
02
/
f90examp.for
< prev
next >
Wrap
Text File
|
1991-02-10
|
6KB
|
171 lines
* The following Fortran 90 code listing fragments are from
* Thomas M. Lahey's article entitled "Fortran 90 is Coming!"
*** LISTING 1
REAL, DIMENSION(:,:), ALLOCATABLE :: temps, pressures
...
n = 16384 ! Try for arrays of 24*8192 elements
10 n = n/2 ! n too big, halve it
ALLOCATE ( temps(24, n), STAT=notice )
IF ( notice .NE. 0 ) GO TO 10 ! temps not allocated
ALLOCATE ( pressures(24, n), STAT=notice )
IF ( notice .NE. 0 ) THEN
DEALLOCATE ( temps ); GO TO 10
ENDIF
! pressures and temps have been allocated 24 by n elements.
IF ( n << 1024 ) THEN
PRINT '(" Only able to allocate"I4," elements")', n
STOP "Quitting"
ENDIF
...
*** LISTING 2
! pntr1 & pntr2 associate only with two-dimensional REAL arrays
COMMON /pointers/ pntr1, pntr2
REAL, POINTER, DIMENSION(:,:) :: pntr1, pntr2
! array1 & array2 are descriptors that "know" they are unallocated
! TARGET is required since they will be associated with a pointer
REAL, TARGET, DIMENSION(:,:) :: array1, array2
...
ALLOCATE ( array1(50,50), array2(70,90) )
pntr1 =>> array1; pntr2 =>> array2 !POINTER ASSIGNMENTs
CALL s ! if s declares COMMON /pointers/, then it can
! access array1 and array2
...
***LISTING 3
FUNCTION elements(string) ! Count words
IMPLICIT NONE; INTEGER i
CHARACTER*(*) string; LOGICAL separator
TYPE inventory
INTEGER nwords, nletters, npunct, nblanks, nelse
END TYPE inventory
TYPE (inventory) elements
! Initialize structure, INTRINSIC TRIM removes trailing blanks
elements%nwords = 0; elements%nletters = 0
elements%npunct = 0; elements%nelse = 0
elements%nblanks = LEN(string) - LEN( TRIM(string) )
IF ( string == '' ) RETURN ! All blanks
separator = .TRUE. ! To count words
block1: DO i = 1, LEN( TRIM(string) ) ! No trailing ' '
SELECT CASE ( string(i:i) )
CASE ( ' ' ) ! Blank
elements%nblanks = elements%nblanks +1
separator = .TRUE.
CASE (a:z, A:Z) ! Letters
elements%nletters = elements%nletters +1
IF ( separator ) THEN ! New word?
nwords = nwords +1 ! Yes
separator = .FALSE.
ENDIF
CASE ( '.', ',', ';' ) ! Punctuation
separator = .TRUE.
elements%npunct = elements%npunct +1
CASE DEFAULT ! All others
elements%nelse = elements%nelse +1
END SELECT
END DO block1
END
***LISTING 4
MODULE ISO_string
! Derived-type dynamic-length CHAR item: POINTER to rank-one array
TYPE string ! User defines DERIVED-TYPE STRINGs
PRIVATE ! Component "chars" unavailable to user
CHARACTER, DIMENSION(:), POINTER :: chars
END TYPE string
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE ! MODULE SUBROUTINEs defined below
& s_eqs_s, ! CALLed if string = string parsed
& s_eqs_c, ! CALLed if string = char parsed
& c_eqs_s ! CALLed if char = string parsed
END INTERFACE
INTERFACE OPERATOR(//)
MODULE PROCEDURE ! MODULE FUNCTIONs defined later
& s_concat_s, ! Invoked if string // string parsed
& s_concat_c, ! Invoked if string // char parsed
& c_concat_s ! Invoked if char // string parsed
END INTERFACE
! Note: The ISO MODULE defines relational operators
! Note: The ISO MODULE defines its INTRINSIC FUNCTIONs LEN, INDEX
! Note: The ISO MODULE defines type conversions for internal
use
! ... A lot more code!
SUBROUTINE s_eqs_s(st, ss)! Compiler CALLs when
! string = string is parsed
TYPE (string) INTENT(OUT) :: st
TYPE (string) INTENT(IN) :: ss
IF ( .NOT. ASSOCIATED(ss%chars) ) CALL error
IF ( ASSOCIATED(st%chars) ) THEN
IF ( ASSOCIATED(ss%chars, st%chars) ) RETURN
NULLIFY (st%chars)
ENDIF
st%chars = ss%chars
END SUBROUTINE s_eqs_s
! ... A lot more code!
END MODULE ISO_string
! Using the string MODULE
USE string ! The MODULE
TYPE (string) s1, s2 ! MODULE has type definition
...
s1 = 'abc def ' ! Trailing blank preserved,
s_eqs_c
s2 = 'ghi jkl mno'
...
s1 = s2 // s1 ! // is overloaded operator,
compiler
! invokes function s_cat_s(s2,s1)
then
! CALL s_eqs_s(s1,string_temp)
PRINT *, s1 ! Compiler prints structure components
END
***LISTING 5
SUBROUTINE sub
CALL s
PRINT *, i, j ! i & j are known to internals
CONTAINS ! Required, separates host & internals
SUBROUTINE s
i = nj(5); END ! i not declared locally, must be host
FUNCTION nj(k)
j = k+5; END ! j not declared locally, must be host
END SUBROUTINE sub
***LISTING 6
NAMELIST /study_params/ temp, pres, volume
REAL, PARAMETER :: n = 6.02252E23, R = 0.0823
10 PRINT *, 'To terminate, enter both values as 0'
PRINT *, 'If not changing both params end with /, no ,'
PRINT *, 'Input: &study_params temp=value, pres=value/'
IF ( temp .EQ. 0 .AND. pres .EQ. 0 ) STOP 'All done'
READ (*, NML=study_params)
volume = n*R*temp/pres ! Remember: PV = nRT
WRITE (*, NML=study_params) ! Outputs: temp, pres, & volume
GO TO 10
END